; ORIGINAL: 3dt2.1/examples/schemers/report.scm
;;
;; report.scm
;;
;;
;; Edward C. Martin, Schemers Inc.
;; 20 January 1994
;; 08 November 1994, removed all mention of the void object, to ensure
;; compatibility with Elk2.2
;;
;; (report <entity>)
;;   prints a comprehensive debug report for a specified entity to stdout
;;
;; (report <entity> <filename>)
;;  where <filename> is given as a string, prints the report to a file.
;;
(define report
  (lambda (ent . arg)
    (let ((outport (if (null? arg) #t (open-output-file (car arg)))))
      (report-ent ent outport)
      (if (output-port? outport)
          (close-output-port outport))
      'done)))

(define report-ent
  (lambda (ent  outport)
    (if (not (entity? ent))
        (begin
          (if (outport-port? outport) (close-output-port outport))
          (error 'report "Argument is not an entity: ~s" ent))
        (if (equal? ent (entity:owner ent))
            (cond
              ((background? ent)
               (begin
                 (format outport "~s: background\n" ent)
                 (format outport "      Type: ~s\n" (background:type ent))
                 (format outport "Properties: ~s\n" (background:props ent))))
              ((material? ent)
               (begin
                 (format outport "~s: material\n" ent)
                 (format outport "             Color type: ~s\n"
                         (material:color-type ent))
                 (format outport "       Color properties: ~s\n"
                         (material:color-props ent))
                 (format outport "      Displacement type: ~s\n"
                         (material:displacement-type ent))
                 (format outport "Displacement properties: ~s\n"
                         (material:displacement-props ent))
                 (format outport "        Reflection type: ~s\n"
                         (material:reflection-type ent))
                 (format outport "  Reflection properties: ~s\n"
                         (material:reflection-props ent))
                 (format outport "      Transparency type: ~s\n"
                         (material:transparency-type ent))
                 (format outport "Transparency properties: ~s\n"
                         (material:transparency-props ent))))
              ((refinement? ent)
               (begin
                 (format outport "~s: refinement\n" ent)
                 (format outport "Refinement properties: ~s\n"
                         (refinement:props ent))))
              ((light? ent)
               (begin
                 (format outport "~s: light\n" ent)
                 (format outport "      Type: ~s\n" (light:type ent))
                 (format outport "Properties: ~s\n" (light:props ent))))
              ((wcs? ent)
               (begin
                 (format outport "~s: working coordinate system:\n" ent)
                 (format outport "Origin: ~s, relative to the active wcs\n"
                         (wcs:origin ent))
                 (format outport "x-axis: ~s, relative to the active wcs\n"
                         (wcs:x-axis ent))
                 (format outport "y-axis: ~s, relative to the active wcs\n"
                         (wcs:y-axis ent))
                 (format outport "z-axis: ~s, relative to the active wcs\n"
                         (wcs:z-axis ent))))
              ((point? ent)
               (format outport "~s: top level point located at ~s.\n" ent
                       (point:position ent)))
              ((vertex? ent)
               (format outport "~s: top level vertex located at ~s.\n" ent
                       (vertex:position ent)))
              ((edge? ent) (report-edge ent " top level" outport))
              ((wire-body? ent)
               (let ((wires (entity:wires ent)))
                 (if (wire-body:planar? ent)
                     (format outport
                             "~s: top level planar wire-body with ~a:\n"
                             ent (agree (length wires) '(wire wires)))
                     (begin
                       (format outport
                               "~s: top level non-planar wire-body with ~a\n"
                               ent (agree (length wires) '(wire wires)))
                       (format outport "and bounding box given by ~s.\n"
                               (entity:box ent))))
                 (for-each (lambda (x) (report-wire x outport)) wires)
                 ))
              ((face:cylindrical? ent)
               (report-face ent " top level" 'cylindrical outport))
              ((face:conical? ent)
               (report-face ent " top level" 'conical outport))
              ((face:planar? ent)
               (report-face ent " top level" 'planar outport))
              ((face:spherical? ent)
               (report-face ent " top level" 'spherical outport))
              ((face:spline? ent)
               (report-face ent " top level" 'spline outport))
              ((face:toroidal? ent)
               (report-face ent " top level" 'toroidal outport))
              ((solid? ent)
               (let ((lumps (entity:lumps ent))
                     (ref (entity:refinement ent)))
                 (format outport "~s: solid body with ~a and\n"
                         ent (agree (length lumps) '(lump lumps)))
                 (format outport "bounding box given by ~s.\n"
                         (entity:box ent))
                 (format outport "The body is~a faceted.\n"
                         (if (entity:faceted? ent) "" " not"))
                 (if ref (report-ent ref outport))
                 (for-each (lambda (x) (report-ent x outport)) lumps)
                 ))
              ((body? ent)
               (let ((lumps (entity:lumps ent))
                     (wires (entity:wires ent))
                     (ref (entity:refinement ent)))
                 (format outport "~s: mixed-type body with ~a and ~a,\n"
                         ent (agree (length lumps) '(lump lumps))
                         (agree (length wires) '(wire wires)))
                 (format outport "and bounding box given by ~s.\n"
                         (entity:box ent))
                 (format outport "The body is~a faceted.\n"
                         (if (entity:faceted? ent) "" " not"))
                 (if ref (report-ent ref outport))
                 (for-each (lambda (x) (report-ent x outport)) lumps)
                 (for-each (lambda (x) (report-wire x outport)) wires)
                 )))
            (cond
              ((lump? ent)
               (let ((shells (entity:shells ent)))
                 (format outport "~s: lump bounded by ~a:\n"
                         ent (agree (length shells) '(shell shells)))
                 (for-each (lambda (x) (report-ent x outport)) shells)
                 ))
              ((shell? ent)
               (let ((faces (entity:faces ent)))
                 (format outport "~s: shell with ~a:\n"
                         ent (agree (length faces) '(face faces)))
                 (for-each (lambda (x) (report-ent x outport)) faces)
                 ))
              ((loop? ent)
               (let ((edges (entity:edges ent)))
                 (format outport "~s: loop containing ~a:\n"
                         ent (agree (length edges) '(edge edges)))
                 (for-each (lambda (x) (report-edge x "" outport)) edges)
                 ))
              ((face:cylindrical? ent)
               (report-face ent "" 'cylindrical outport))
              ((face:conical? ent) (report-face ent "" 'conical outport))
              ((face:planar? ent) (report-face ent "" 'planar outport))
              ((face:spherical? ent) (report-face ent "" 'spherical outport))
              ((face:spline? ent) (report-face ent "" 'spline outport))
              ((face:toroidal? ent) (report-face ent "" 'toroidal outport))
              ((edge? ent) (report-edge ent "" outport))
              ((vertex? ent)
               (format outport "~s: vertex located at ~s\n"
                       ent (vertex:position ent)))
              )))))

(define report-edge
  (lambda (edge level outport)
    (let ((verts (entity:vertices edge)))
      (cond
        ((not (edge:curve? edge))
         (format outport "~s:~a degenerate edge with no associated curve,"
                 edge level)
         (format outport " but with ~a:\n"
                 (agree (length verts) '(vertex vertices))))
        ((edge:circular? edge)
         (format outport "~s:~a circular edge with" edge level)
         (format outport " center at ~s," (arc:center edge))
         (format outport " radius ~s, and" (arc:radius edge))
         (format outport " ~a:\n" (agree (length verts) '(vertex vertices))))
        ((edge:elliptical? edge)
         (format outport "~s:~a elliptical edge with" edge level)
         (format outport " center at ~s," (arc:center edge))
         (format outport " principal axis in the direction ~s, and"
                 (arc:major-axis edge))
         (format outport " ~a:\n" (agree (length verts) '(vertex vertices))))
        ((edge:linear? edge)
         (format outport "~s:~a linear edge with ~a:\n"
                 edge level (agree (length verts) '(vertex vertices))))
        ((edge:spline? edge)
         (format outport "~s:~a spline edge with ~a:\n"
                 edge level (agree (length verts) '(vertex vertices))))
        (else (error 'report "unrecognized type of edge: ~s" edge)))
      (for-each (lambda (x) (report-ent x outport)) verts)
      )))

(define report-wire
  (lambda (wire outport)
    (let ((edges (entity:edges wire)))
      (if (wire:planar? wire)
          (format outport "~s: planar wire containing ~a:\n"
                  wire (agree (length edges) '(edge edges)))
          (format outport "~s: non-planar wire containing ~a:\n"
                  wire (agree (length edges) '(edge edges))))
      (for-each (lambda (x) (report-edge x "" outport)) edges)
      )))

(define report-face
  (lambda (face level type outport)
    (let ((loops (entity:loops face)))
      (case type
        ((conical)
         (begin
           (format outport "~s:~a conical face with ~a:\n"
                   face level (agree (length loops) '(loop loops)))))
        ((cylindrical)
         (begin
           (format outport "~s:~a cylindrical face with radius ~s, "
                   face level (face:cylinder-radius face))
           (format outport "axis given by ~s, and ~a:\n"
                   (face:cylinder-axis face)
                   (agree (length loops) '(loop loops)))))
        ((planar)
         (begin
           (format outport "~s:~a planar face with normal in the direction ~s"
                   face level (face:plane-normal face))
           (format outport " and ~a:\n"
                   (agree (length loops) '(loop loops)))))
        ((spherical)
         (begin
           (format outport "~s:~a spherical face with center at ~s, "
                   face level (face:sphere-center face))
           (format outport "radius ~s, and ~a:\n"
                   (face:sphere-radius face) (agree (length loops) '(loop loops)))))
        ((spline)
         (format outport "~s:~a spline face with ~a:\n"
                 face level (agree (length loops) '(loop loops))))
        ((toroidal)
         (format outport "~s:~a toroidal face with ~a.\n"
                 face level (agree (length loops) '(loop loops)))))
      (format outport "The face is~a faceted.\n"
              (if (entity:faceted? face) "" " not"))
      (let ((ref (entity:refinement face)))
        (if ref (report-ent ref outport))
        (for-each (lambda (x) (report-ent x outport)) loops)
        ))))

(define agree
  (lambda (num alternatives)
    (string-append
      (number->string num)
      " "
      (if (= num 1)
          (symbol->string (car alternatives))
          (symbol->string (cadr alternatives))))))

;;
;; (report-event <event>)
;; prints the external representation of <event>, and then records the
;; results of applying the ten event-inquiry procedures.
;;
(define report-event
  (lambda (evt)
    (format #t "~a\n" evt)
    (format #t "  event:button -- ~a\n" (event:button evt))
    (format #t "    event:view -- ~a\n" (event:view evt))
    (format #t "       event:x -- ~a\n" (event:x evt))
    (format #t "       event:y -- ~a\n" (event:y evt))
    (format #t "    event:alt? -- ~a\n" (event:alt? evt))
    (format #t "event:control? -- ~a\n" (event:control? evt))
    (format #t "  event:shift? -- ~a\n" (event:shift? evt))
    (format #t "   event:left? -- ~a\n" (event:left? evt))
    (format #t " event:middle? -- ~a\n" (event:middle? evt))
    (format #t "  event:right? -- ~a\n" (event:right? evt))
    ))

;; end of file  report.scm
